home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / scamacr < prev    next >
Text File  |  1993-09-08  |  6KB  |  167 lines
  1. ;;; This file was munged by a simple minded sed script since it left
  2. ;;; its original authors' hands.  See syncase.doc for the horrid details.
  3.  
  4. ;;; macro-defs.ss
  5. ;;; Robert Hieb & Kent Dybvig
  6. ;;; 92/06/18
  7.  
  8. (define-syntax with-syntax
  9.    (lambda (x)
  10.       (syntax-case x ()
  11.          ((_ () e1 e2 ...)
  12.           (syntax (begin e1 e2 ...)))
  13.          ((_ ((out in)) e1 e2 ...)
  14.           (syntax (syntax-case in () (out (begin e1 e2 ...)))))
  15.          ((_ ((out in) ...) e1 e2 ...)
  16.           (syntax (syntax-case (list in ...) ()
  17.                      ((out ...) (begin e1 e2 ...))))))))
  18.  
  19. (define-syntax syntax-rules
  20.    (lambda (x)
  21.       (syntax-case x ()
  22.          ((_ (k ...) ((keyword . pattern) template) ...)
  23.           (with-syntax (((dummy ...)
  24.                          (generate-temporaries (syntax (keyword ...)))))
  25.              (syntax (lambda (x)
  26.                         (syntax-case x (k ...)
  27.                            ((dummy . pattern) (syntax template))
  28.                            ...))))))))
  29.  
  30. (define-syntax or
  31.    (lambda (x)
  32.       (syntax-case x ()
  33.          ((_) (syntax #f))
  34.          ((_ e) (syntax e))
  35.          ((_ e1 e2 e3 ...)
  36.           (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
  37.  
  38. (define-syntax and
  39.    (lambda (x)
  40.       (syntax-case x ()
  41.          ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
  42.          ((_ e) (syntax e))
  43.          ((_) (syntax #t)))))
  44.  
  45. (define-syntax cond
  46.    (lambda (x)
  47.       (syntax-case x (else =>)
  48.          ((_ (else e1 e2 ...))
  49.           (syntax (begin e1 e2 ...)))
  50.          ((_ (e0))
  51.           (syntax (let ((t e0)) (if t t))))
  52.          ((_ (e0) c1 c2 ...)
  53.           (syntax (let ((t e0)) (if t t (cond c1 c2 ...)))))
  54.          ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t)))))
  55.          ((_ (e0 => e1) c1 c2 ...)
  56.           (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...)))))
  57.          ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...))))
  58.          ((_ (e0 e1 e2 ...) c1 c2 ...)
  59.           (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...)))))))
  60.  
  61. (define-syntax let*
  62.    (lambda (x)
  63.       (syntax-case x ()
  64.          ((let* () e1 e2 ...)
  65.           (syntax (let () e1 e2 ...)))
  66.          ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...)
  67.           (comlist:every identifier? (syntax (x1 x2 ...)))
  68.           (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...)))))))
  69.  
  70. (define-syntax case
  71.    (lambda (x)
  72.       (syntax-case x (else)
  73.          ((_ v (else e1 e2 ...))
  74.           (syntax (begin v e1 e2 ...)))
  75.          ((_ v ((k ...) e1 e2 ...))
  76.           (syntax (if (memv v '(k ...)) (begin e1 e2 ...))))
  77.          ((_ v ((k ...) e1 e2 ...) c1 c2 ...)
  78.           (syntax (let ((x v))
  79.                      (if (memv x '(k ...))
  80.                          (begin e1 e2 ...)
  81.                          (case x c1 c2 ...))))))))
  82.  
  83. (define-syntax do
  84.    (lambda (orig-x)
  85.       (syntax-case orig-x ()
  86.          ((_ ((var init . step) ...) (e0 e1 ...) c ...)
  87.           (with-syntax (((step ...)
  88.                          (map (lambda (v s)
  89.                                  (syntax-case s ()
  90.                                     (() v)
  91.                                     ((e) (syntax e))
  92.                                     (_ (syntax-error orig-x))))
  93.                               (syntax (var ...))
  94.                               (syntax (step ...)))))
  95.              (syntax-case (syntax (e1 ...)) ()
  96.                 (() (syntax (let doloop ((var init) ...)
  97.                                (if (not e0)
  98.                                    (begin c ... (doloop step ...))))))
  99.                 ((e1 e2 ...)
  100.                  (syntax (let doloop ((var init) ...)
  101.                             (if e0
  102.                                 (begin e1 e2 ...)
  103.                                 (begin c ... (doloop step ...))))))))))))
  104.  
  105. (define-syntax quasiquote
  106.    (letrec
  107.       ((gen-cons
  108.         (lambda (x y)
  109.            (syntax-case x (quote)
  110.               ((quote x)
  111.                (syntax-case y (quote list)
  112.                   ((quote y) (syntax (quote (x . y))))
  113.                   ((list y ...) (syntax (list (quote x) y ...)))
  114.                   (y (syntax (cons (quote x) y)))))
  115.               (x (syntax-case y (quote list)
  116.                    ((quote ()) (syntax (list x)))
  117.                    ((list y ...) (syntax (list x y ...)))
  118.                    (y (syntax (cons x y))))))))
  119.  
  120.        (gen-append
  121.         (lambda (x y)
  122.            (syntax-case x (quote list cons)
  123.               ((quote (x1 x2 ...))
  124.                (syntax-case y (quote)
  125.                   ((quote y) (syntax (quote (x1 x2 ... . y))))
  126.                   (y (syntax (append (quote (x1 x2 ...) y))))))
  127.               ((quote ()) y)
  128.               ((list x1 x2 ...)
  129.                (gen-cons (syntax x1) (gen-append (syntax (list x2 ...)) y)))
  130.               (x (syntax-case y (quote list)
  131.                    ((quote ()) (syntax x))
  132.                    (y (syntax (append x y))))))))
  133.  
  134.        (gen-vector
  135.         (lambda (x)
  136.            (syntax-case x (quote list)
  137.               ((quote (x ...)) (syntax (quote #(x ...))))
  138.               ((list x ...) (syntax (vector x ...)))
  139.               (x (syntax (list->vector x))))))
  140.  
  141.        (gen
  142.         (lambda (p lev)
  143.            (syntax-case p (unquote unquote-splicing quasiquote)
  144.               ((unquote p)
  145.                (if (= lev 0)
  146.                    (syntax p)
  147.                    (gen-cons (syntax (quote unquote))
  148.                              (gen (syntax (p)) (- lev 1)))))
  149.               (((unquote-splicing p) . q)
  150.                (if (= lev 0)
  151.                    (gen-append (syntax p) (gen (syntax q) lev))
  152.                    (gen-cons (gen-cons (syntax (quote unquote-splicing))
  153.                                        (gen (syntax p) (- lev 1)))
  154.                              (gen (syntax q) lev))))
  155.               ((quasiquote p)
  156.                (gen-cons (syntax (quote quasiquote))
  157.                          (gen (syntax (p)) (+ lev 1))))
  158.               ((p . q)
  159.                (gen-cons (gen (syntax p) lev) (gen (syntax q) lev)))
  160.               (#(x ...) (gen-vector (gen (syntax (x ...)) lev)))
  161.               (p (syntax (quote p)))))))
  162.  
  163.     (lambda (x)
  164.        (syntax-case x ()
  165.           ((- e) (gen (syntax e) 0))))))
  166.  
  167.